perm filename DEFMAC[MAC,LSP] blob sn#581967 filedate 1981-04-22 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00010 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	   DEFMAC  -*-mode:lisppackage:si-*- 		  -*-LISP-*-   
C00005 00003
C00007 00004
C00013 00005
C00023 00006
C00028 00007
C00032 00008
C00039 00009
C00052 00010
C00054 ENDMK
C⊗;
;;;   DEFMAC  -*-mode:lisp;package:si-*- 		  -*-LISP-*-   
;;;   **************************************************************
;;;   ***** NIL ******** DEFUN& and DEFMACRO ***********************
;;;   **************************************************************
;;;   ** (C) COPYRIGHT 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;;   ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;;   **************************************************************

(eval-when (eval compile)
	   (cond ((and (status feature MACLISP) (status nofeature FOR-NIL)) 
		  (sstatus feature FM)
		  (sstatus feature FOR-MACLISP)))
	   )

(herald DEFMACRO /158)


#-For-NIL 
(defun LISPDIR macro (x)
     `(QUOTE ((LISP) ,(cadr x) #+Pdp10 FASL)))

#-For-NIL 
(defun SUBLOAD macro (x)
   (setq x (cadr x))
   `(OR (GET ',x 'VERSION) (LOAD #%(lispdir ,x))))


#-For-NIL 
(eval-when (eval load compile)
	   (subload DEFMAX)
	   (subload MACAID)
)

#-FM 
(globalize  "DEFUN&"
	    "DEFUN&-CHECK-ARGS" 
	    "&r-l/|"
	    "DEFMACRO" 
	    "DEFMACRO-DISPLACE" 
	    "LET" "LET*" "DESETQ")

(declare (special DEFMACRO-CHECK-ARGS  		;These are user-settable
		  DEFMACRO-DISPLACE-CALL 	; switches.
		  DEFMACRO-FOR-COMPILING 
		  DEFUN&-CHECK-ARGS 
		  MACRO-EXPANSION-USE 
		  GRIND-MACROEXPANDED ))

#-(or NIL (and For-NIL (not MACLISP)) LISPM)
(declare (*expr STRINGP))

;; This OWN-SYMBOL declaration is here so that it is easy to change
;; the number of arguments; also prevents the spurious error messages.
#-Lispm
(declare (own-symbol DEFUN& DEFUN&-ERROR |&r-l/|| |&o-l/|| |&a-l/||
		     |cnvd-checkautoload/||  |map-cnvd/|| 
		     |Certify-no-var-dependency/||  |defmacro-1/||))



(DECLARE #M (SETQ MAPEX 'T)
	 (*EXPR DEFUN&-ERROR |&r-l/|| |&restv-ify/||) 
	 (SPECIAL DEFUN&-ERROR |&r-l/|| |&restv-ify/||)
	 (SPECIAL BAD-VARS BOUND-VARS ALL-LOCALS SUPPLIEDP-VARS))

(DECLARE (*EXPR MACROMEMO MACROFETCH |forget-macromemos/|| FLUSH-MACROMEMOS)
	 (SPECIAL MACROMEMO MACROEXPANDED 
		  FLUSH-MACROMEMOS DEFMAX-COUNTER-VARIABLES))

(SETQ-IF-UNBOUND DEFUN&-CHECK-ARGS () )
#+FM (SETQ-IF-UNBOUND |&r-l/|| 'LISTIFY) 

#Q (macro PAIRP (x) `(NOT (ATOM ,(cadr x))))

(DEFUN DEFUN&-ERROR ()
   (ERROR '|Bad variable-list syntax -- DEFUN& | DEFUN&-ERROR))

(MACRO DEFUNP (X) (DEFUN&-aux/| x 'T)) 
(MACRO DEFUN& (X) (DEFUN&-aux/| x () )) 


;;;; DEFUN& for non-MacLISP

#-FM (progn 'compile 

(DEFUN DEFUN&-aux/| (X DEFUNPP)
   (PROG (NAME VARLIST BODY DEFUN&-ERROR DECLS KEYWORDP LETLIST 
	    ALLFLATS INSETQS BOUND-VARS BAD-VARS ALL-LOCALS KEYWORDS 
	    IVARLIST VARL TMPVAR LAMVAR TEM SUPPLIEDP-VAR USERCOMMENT?)
	 (DECLARE (SPECIAL ALL-LOCALS BOUND-VARS BAD-VARS))
	 (SETQ X (CDR X) NAME (CAR X) IVARLIST (SETQ DEFUN&-ERROR (CADR X))
	       BODY (CDDR X))
	 (AND (NOT (ATOM NAME)) (SETQ NAME (CAR NAME)))			
	 (COND ((EQ IVARLIST 'EXPR) 
		(SETQ IVARLIST (CAR BODY) BODY (CDR BODY)))
	       ((MEMQ IVARLIST '(MACRO FEXPR)) 
		(ERROR '|Can't DEFUN& for FEXPR or MACRO| (CONS 'DEFUN X)))
	       ((AND IVARLIST (OR (ATOM IVARLIST) (CDR (LAST IVARLIST))))
		(DEFUN&-ERROR)))
	 (MULTIPLE-VALUE (BODY DECLS USERCOMMENT?) 
			 (|def-decl-comment?/|| BODY X))
	 (COND 
	  ((NOT DEFUNPP)
	   (DO VARL IVARLIST (CDR VARL) (NULL VARL)
	      (COND ((ATOM (CAR VARL))
		     (OR (SYMBOLP (CAR VARL)) (DEFUN&-ERROR))
		     (COND ((MEMQ (CAR VARL) 
				  '(&OPTIONAL &REST &RESTL &RESTV &AUX))
			    (SETQ KEYWORDP (CAR VARL)) 
			    (AND (COND ((MEMQ KEYWORDP KEYWORDS))
				       ((EQ KEYWORDP '&OPTIONAL)
					(PUSH '&OPTIONAL KEYWORDS)
					(OR (MEMQ '&AUX KEYWORDS)
					    (MEMQ '&REST KEYWORDS)))
				       ((MEMQ KEYWORDP '(&REST &RESTL &RESTV))
					(PUSH '&REST KEYWORDS)
					(MEMQ '&REST (CDR KEYWORDS)))
				       ('T (PUSH '&AUX KEYWORDS) () ))
				 (DEFUN&-ERROR)))
			   ('T (PUSH (CAR VARL) BAD-VARS)))
		     (COND ((EQ KEYWORDP '&AUX)
			    (AND (NOT (EQ (CAR VARL) '&AUX)) 
				 (PUSH (CAR VARL) LETLIST)))
			   ('T (PUSH (CAR VARL) VARLIST))))
		    ((NOT KEYWORDP)
		      ;case of required argument with destructuring
		     (SETQ BAD-VARS (FLATTEN-SYMS (CAR VARL) BAD-VARS)
			   TMPVAR (GENTEMP "Reqd-Var"))
		     (PUSH `(,(car varl) ,tmpvar) LETLIST)
		     (PUSH TMPVAR VARLIST))
		    ('T (SETQ TMPVAR  
			      (COND 
			        ((ATOM (CAAR VARL))
				 (OR (SYMBOLP (SETQ TMPVAR (CAAR VARL)))
				     (DEFUN&-ERROR))
				 (PUSH (SETQ LAMVAR (CAAR VARL)) BAD-VARS)
				 () ) 
				('T (SETQ BAD-VARS (FLATTEN-SYMS (CAAR VARL) 
								 BAD-VARS))
				    (SETQ LAMVAR (GENTEMP "&var")))))
			(COND ((AND (CDAR VARL)
				    (NOT (EQ (CADAR VARL) LAMVAR))
				    (NOT (|Certify-no-var-dependency/|| (CADAR VARL))))
			       (SETQ ALLFLATS (FLATTEN-SYMS (CAAR VARL) ALLFLATS))
			       (SETQ TEM `(DESETQ ,(caar varl) 
						  ,(or tmpvar (cadar varl))))
			       (COND ((SETQ SUPPLIEDP-VAR (CADDAR VARL))
				      (OR (SYMBOLP SUPPLIEDP-VAR) 
					  (DEFUN&-ERROR)))
				     ('T (SETQ SUPPLIEDP-VAR
					       (GENTEMP "Supplied-P"))))
			       (PUSH (COND ((EQ KEYWORDP '&OPTIONAL)
					    `(OR ,suppliedp-var ,tem))
					   (TEM))
				     INSETQS)
			       (OR (EQ KEYWORDP '&AUX)
				   (PUSH `(,lamvar () ,suppliedp-var) VARLIST)))
			      ((EQ KEYWORDP '&AUX) (PUSH (CAR VARL) LETLIST))
			      ('T (AND TMPVAR 
				       (PUSH `(,(caar varl) ,tmpvar) LETLIST))
				  (PUSH `(,lamvar  ,. (cdar varl)) VARLIST))))))
	   (MAP '(LAMBDA (X) (AND (CAR X) (MEMQ (CAR X) (CDR X)) (DEFUN&-ERROR)))
		BAD-VARS)
	   (AND (OR LETLIST ALLFLATS INSETQS)
		(SETQ BODY `((LET (,.(nreverse letlist) ,.allflats)
				  ,.(nreverse insetqs)
				  ,. body))))
	   (push `(COMMENT ARGLIST = ,defun&-error) body)
	   )
	  ('T (SETQ BODY (REVERSE BODY))
	      (SETQ BODY `((PROG () ,.(nreverse (cons `(RETURN ,(car body))
						      (cdr body))))))))
	 (SETQ BODY `(,.decls ,.usercomment? ,. body))
	 (RETURN 
	   (COND 
	    (DEFUNPP `(DEFUN ,name ivarlist ,.body))
	    (`(FSET ',name (FUNCTION (LAMBDA ,(nreverse varlist) ,.body))))))
	  ))

  )	;end of #-FM


;;;; DEFUN& for MacLISP

#+FM (progn 'compile  

;;; A loop for going down the VARLIST and consing up forms
;;;   stops when the tail is at MORE
;;; Requires some variables to be setup - MORE  ARGNO
;;; Provides some variables for the body - VARL 
;;; Increments ARGNO

(defun si:MAP-VL macro (x)
   `(DO ((VARL VARLIST (CDR VARL))
	 (ANSL () (CONS ,(cadr x) ANSL)))
	((EQ VARL MORE) ANSL)
      (SETQ ARGNO (1+ ARGNO))))


(DEFUN DEFUN&-aux/| (X DEFUNPP)
   (LET ((DCA DEFUN&-CHECK-ARGS) (MIN 0)  (MAX 262143.) (ARGNO 0)
	  NAME-ARG VARLIST BODY DEFUN&-ERROR  SUPPLIEDP-VARS  |&restv-ify/|| 
	  LEXPRVAR  ALLFLATS  ALLVARS  MORE  LETLIST  DECLS  INSETQS  
	  USERCOMMENT?  TMP  IVARLIST)
        (SETQ X (CDR X) NAME-ARG (CAR X) VARLIST (CADR X) BODY (CDDR X))
	(COND ((EQ VARLIST 'EXPR) (POP BODY VARLIST))
	      ((MEMQ VARLIST '(MACRO FEXPR)) 
	       (ERROR '|Can't DEFUN& for FEXPR or MACRO| 
		      `(DEFUN& ,name-arg ,varlist ,. body))))
	(COND ((NULL (SETQ DEFUN&-ERROR  ;Eliminate &AUXs from VARLIST for msg
			   (OR (NREVERSE (CDR (MEMQ '&AUX (REVERSE VARLIST))))
			       VARLIST)))
	       ())
	      ((AND VARLIST (OR (ATOM VARLIST) (CDR (LAST VARLIST))))
	       (DEFUN&-ERROR)))
	(SETQ IVARLIST VARLIST)
	(MULTIPLE-VALUE (BODY DECLS USERCOMMENT?)
			(|def-decl-comment?/|| BODY X))
	(COND 
	 (DEFUNPP 
	  (SETQ BODY (REVERSE BODY))
	  (SETQ BODY `((PROG () ,.(nreverse (cons `(RETURN ,(car body))
						  (cdr body)))))))
	 ('T 
	  (COND 
	    ((SETQ MORE (OR (MEMQ '&OPTIONAL VARLIST)
			    (&REST-P VARLIST)))
	      (SETQ LEXPRVAR (GENTEMP "LexprVar")
		    LETLIST (si:MAP-VL `(,(car varl) (ARG ,argno)))
		    MIN (LENGTH LETLIST)
		    MAX (COND ((&REST-P MORE) () )
			      ((+ MIN (- (LENGTH (CDR MORE))
					 (LENGTH (MEMQ '&AUX (CDR MORE)))))))
		    LETLIST (NRECONC LETLIST 
				     (COND ((EQ (POP MORE TMP) '&OPTIONAL) 
					    (|&o-l/|| MORE ARGNO LEXPRVAR))
					   ((|&r-l/|| MORE ARGNO LEXPRVAR
						      TMP))))
		    VARLIST LEXPRVAR ))
	    ('T (COND ((SETQ MORE (MEMQ '&AUX VARLIST))
		        (SETQ VARLIST (BUT-TAIL VARLIST MORE))
			(SETQ LETLIST (|&a-l/|| (CDR MORE)))))
		(SETQ MAX (SETQ MIN (LENGTH VARLIST)))
		(COND ((DO L VARLIST (CDR L) (NULL L) 
			   (AND (CAR L) (NOT (SYMBOLP (CAR L))) (RETURN 'T)))
		        (SETQ VARLIST 
			      (MAPCAR 
				'(LAMBDA (VAR)
				   (COND ((OR (NULL VAR) (SYMBOLP VAR))  VAR)
					 ('T (SETQ TMP (GENTEMP "Reqd-Var"))
					     (PUSH `(,var ,tmp) LETLIST)
					     TMP)))
				VARLIST) )))))
	  (COND (SUPPLIEDP-VARS 
		 (SETQ ALLFLATS (NCONC (MAPCAR 'CAR SUPPLIEDP-VARS) ALLFLATS))
		 (SETQ BODY (NCONC (MAPCAR 
				    '(LAMBDA (X) 
				       `(AND (> ,lexprvar ,(1- (cdr x)))
					     (SETQ ,(caar x) 'T)))
				    SUPPLIEDP-VARS)
				   BODY)) ))
	  (MAP #'(LAMBDA (X) 
		   (AND (CAR X) (MEMQ (CAR X) (CDR X)) (DEFUN&-ERROR)))
	       (SETQ ALLVARS (FLATTEN-SYMS 
			       (MAPCAR #'CAR LETLIST)
			       (COND (LEXPRVAR  ALLFLATS) ;VARLIST is atomic?
				     ((FLATTEN-SYMS VARLIST ALLFLATS))))))
	  (COND (LETLIST 
		  (LET ((SVARS (MAPCAN '(LAMBDA (X)				
					  (AND (NOT (ATOM X))
					       (EQ (CAR X) 'SPECIAL)
					       (APPEND (CDR X) () )))
				       (CDAR DECLS)))
			(ALL-LOCALS 'T)
			(BOUND-VARS)
			(BAD-VARS ALLVARS)
			(FLAG) )
		    (DECLARE (SPECIAL BAD-VARS BOUND-VARS ALL-LOCALS))
		    (MAPC #'(LAMBDA (Y)
			      (AND (OR (GET Y 'SPECIAL)
				       (NOT (MEMQ COMPILER-STATE '(COMPILE MAKLAP)))
				        ;This clause would allow more extended 
				        ;declarations  of special variables, by
				        ;adding names on this special list
				        ; (MEMQ Y SPECIAL-VARIABLES)
				       (MEMQ Y SVARS))
				   (SETQ ALL-LOCALS () )))
			  BAD-VARS)
		    (MAP #'(LAMBDA (L)
			     ;Analyze variable dependencies in left-to-right 
			     ;view of default values for &optionals and &auxs
			    (COND 
			      ((AND (CDAR L)
				    (NOT (EQ (SETQ TMP (CADAR L)) (CAAR L)))
				    (COND (LEXPRVAR)  ;VARLIST is atomic?
					  ((SYMBOLP TMP)
					   (NOT (MEMQ TMP VARLIST)))
					  ('T))
				     (NOT (|Certify-no-var-dependency/|| TMP)))
			       (SETQ FLAG 'T)
			       (SETQ ALLFLATS (FLATTEN-SYMS (CAAR L) ALLFLATS))
			       (PUSH `(DESETQ ,(caar l) ,(cadar l))
				     INSETQS)
			       (RPLACA L () ))))
			 LETLIST)
		    (AND FLAG (SETQ LETLIST (DELQ () LETLIST))) )))
	  (COND ((OR ALLFLATS LETLIST)
		 (SETQ BODY `((LET (,.(nreverse letlist) ,.allflats)
				    ,.(nreverse insetqs)
				    ,. body)))))
	  (COND ((AND DCA LEXPRVAR (OR MAX (NOT (= 0 MIN))))
		   ;;If wrong number of arguments, enter an error handler.
		   ;;A form may be returned so eval it and return as
		   ;; value of function.
		  (LET ((MSG)
			(PREDICATE)
			(CHECKARGS `(LIST (CONS ',name-arg (LISTIFY ,lexprvar))
					  ',defun&-error)))
		    (COND ((AND MAX (NOT (= 0 MIN)))
			   (SETQ MSG `(COND ((> ,lexprvar ,max)
					     '|Too many arguments supplied |)
					    ('|Too few arguments supplied |)))
			   (SETQ PREDICATE
				 (COND ((= MAX MIN)
					`(NOT (= ,lexprvar ,max)))

				       ('T `(OR (< ,lexprvar ,min)
						(> ,lexprvar ,max))))))
			  (MAX
			   (SETQ MSG ''|Too many arguments supplied |)
			   (SETQ PREDICATE `(> ,lexprvar ,max)))
			  ((NOT (= 0 MIN))
			   (SETQ MSG ''|Too few arguments supplied |)
			   (SETQ PREDICATE `(< ,lexprvar ,min))))
		    (SETQ BODY
			  `((COND (,predicate (EVAL (ERROR ,msg 
							   ,checkargs 
							   'WRNG-NO-ARGS)))
				  ('T ,.body)))))) )
	  (PUSH `(COMMENT ARGLIST = ,defun&-error)  BODY)
	 ))
	(SETQ BODY `(DEFUN ,name-arg ,varlist
			   ,.decls
			   ,.usercomment? 
			   ,.body))
	 ;;If DEFUN&-CHECK-ARGS is NIL, then let APPLY check the number
	 ;; of args via the ARGS mechanism.
	(and (cond ((and lexprvar (symbolp name-arg)) 
		    (setq tmp `((ARGS ',name-arg '(,min . ,(or max 510.)))))
		    'T)
		   (|&restv-ify/|| (setq tmp () ) 'T))
	     (setq body `(PROGN 'COMPILE
				,@|&restv-ify/|| 
				,body 
				,.tmp )))
	BODY))


;;;; Helper Funs for MacLISP DEFUN&


;;; Does a list have a member of the &REST family, however they may be spelled.

(DEFUN &REST-P (VARLIST)
  (OR (MEMQ '&REST VARLIST)
      (MEMQ '&RESTL VARLIST)
      (MEMQ '&RESTV VARLIST)))


;;; Process a varlist that follows an &OPTIONAL.
;;; The remainder may have an &REST and/or and &AUX.
;;; ARGNO is one less than the index number of the argument at 
;;;	the first of the list
(DEFUN |&o-l/|| (VARLIST ARGNO LEXPRVAR)
       (AND (MEMQ '&OPTIONAL VARLIST) (DEFUN&-ERROR))
       (LET ((MORE (OR (&REST-P VARLIST) (MEMQ '&AUX VARLIST)))  TMP )
	    (NRECONC 
	     (si:MAP-VL 
	      (COND ((SYMBOLP (CAR VARL))
		     `(,(car varl) (AND (> ,lexprvar ,(1- argno)) (ARG ,argno))))
		    ((COND ((PROG2 (SETQ TMP () ) (ATOM (CAR VARL))))
			   ((ATOM (CDAR VARL)) (CDAR VARL))
			   ((ATOM (SETQ TMP (CDDAR VARL)))  TMP)
			   ((OR (CDR TMP) 
				(NULL (CAR TMP))
				(NOT (SYMBOLP (CAR TMP))))))
		     (DEFUN&-ERROR))
		    ('T (AND TMP (PUSH (CONS TMP ARGNO) SUPPLIEDP-VARS))
			`(,(caar varl) (COND ((> ,lexprvar ,(1- argno))
					      (ARG ,argno))
					     (,(cadar varl)))))))
		(COND ((NULL MORE) () )
		      ((MEMQ (POP MORE TMP) '(&REST &RESTL &RESTV))
		       (|&r-l/|| MORE ARGNO LEXPRVAR TMP))
		      ('T (|&a-l/|| MORE))))))


;;; Process a varlist that follows a member of the &REST family.
;;; ARGNO is one less than the index number of argument at the head of the list
;;; RESTIFY is one of &REST, &RESTV, or &RESTL.  We make the apropriate
;;; selection of the LISTIFY or |&restv-ify/||.  If it's &REST, the value of
;;; |&r-l/|| is selected.

(DEFUN |&r-l/|| (VARLIST ARGNO LEXPRVAR RESTIFY)
  (AND (OR (NOT (SYMBOLP (CAR VARLIST)))
	   (&REST-P VARLIST)
	   (MEMQ '&OPTIONAL VARLIST)
	   (EQ (CAR VARLIST) '&AUX) )
       (DEFUN&-ERROR))
  (SETQ RESTIFY
	(COND ((EQ RESTIFY '&REST) |&r-l/||)
	      ((EQ RESTIFY '&RESTL) 'LISTIFY)
	      ((EQ RESTIFY '&RESTV) '|&restv-ify/||)))
  (AND (EQ RESTIFY '|&restv-ify/||) 	;Signal this case!  May have to 
       (SETQ |&restv-ify/|| 		; output a putprop for autoloading
	     '((OR (GETL '|&restv-ify/|| '(SUBR AUTOLOAD))
		   (DEFPROP |&restv-ify/|| #.(lispdir VECTOR) AUTOLOAD)))))
  (SETQ ARGNO (COND ((= ARGNO 0) `(,restify ,lexprvar))	 ;restify may = LISTIFY
		    (`(AND (> ,lexprvar ,argno) 
			   (,restify (- ,argno ,lexprvar))))))
  (SETQ LEXPRVAR (COND ((NULL (CDR VARLIST)) () ) 
		       ((EQ (CADR VARLIST) '&AUX) (|&a-l/|| (CDDR VARLIST)))
		       ((DEFUN&-ERROR))) ) 
  (COND ((NULL (CAR VARLIST)) LEXPRVAR)
	((CONS `(,(car varlist) ,argno) LEXPRVAR))))


;;; Process a varlist that follows an &AUX.
(DEFUN |&a-l/|| (VARLIST)
  (MAPCAR '(LAMBDA (VAR)
	    (COND ((MEMQ VAR '(&AUX &OPTIONAL &REST &RESTL &RESTV))
		   (DEFUN&-ERROR))
		  ((SYMBOLP VAR) `(,var () ))
		  ((ATOM VAR) (DEFUN&-ERROR))
		  (`(,(car var) ,(cadr var))) ))
	  VARLIST))

)	;end of #+FM 

;;;; |Certify-no-var-dependency/|| and common utility functions

;;; Functions on this page needed by both DEFUN& and DEFMACRO

#+FM (or (getl 'BUT-TAIL '(SUBR AUTOLOAD))
	 (defprop BUT-TAIL #.(lispdir MACAID) AUTOLOAD))

(DEFUN |def-decl-comment?/|| (BODY FORM)
    "Process a DEFUN/DEFMACRO body for initial documentation strings 
     and/or local DECLAREs."
   (LET (USERCOMMENT? DECLARE?)
     (OR (PAIRP BODY) (ERROR '|Bad code-body for definition| FORM))
     (AND (PAIRP (CAR BODY)) 
	  (EQ (CAAR BODY) 'DECLARE)
	  (POP BODY DECLARE?))
     (AND  #+(or (and For-NIL (not MACLISP)) LISPM)
	  (STRINGP (CAR BODY))
	   #-(or (and For-NIL (not MACLISP)) LISPM)
	  (COND ((OR (NULL (CAR BODY)) (PAIRP (CAR BODY)))
		  () )
		((SYMBOLP (CAR BODY)) 
		  (GET (CAR BODY) '+INTERNAL-STRING-MARKER))
		((AND (GET 'STRINGP 'SUBR) (STRINGP (CAR BODY)))))
	  (POP BODY USERCOMMENT?))
     (AND (PAIRP (CAR BODY)) 
	  (EQ (CAAR BODY) 'DECLARE)
	  (POP BODY DECLARE?))
     (VALUES BODY 
	     (IF DECLARE? (LIST DECLARE?)) 
	     (IF USERCOMMENT? (LIST USERCOMMENT?)))))


#+FM 
(DEFUN |APPLICABLEP-cnvd/|| MACRO (X) `(GETL ,(cadr x) '(SUBR LSUBR)))

#-FM 
(DEFUN |APPLICABLEP-cnvd/|| (X)
   (AND (SYMBOLP X)
	(FBOUNDP X)
	(SUBRP (FSYMEVAL X))
    #Q	(NOT (MEMQ X '(COND PROG SETQ OR AND STATUS SSTATUS SIGNP DO PSETQ 
			    ERRSET CATCH *CATCH CATCHALL CATCH-BARRIER )))
	 ))

#-LISPM 
(DEFUN |cnvd-checkautoload/|| (FORM)
   (COND ((OR (ATOM FORM) (NOT (SYMBOLP (CAR FORM)))) () )
         ((AND (GET (CAR FORM) 'AUTOLOAD)
	       (NOT (FBOUNDP (CAR FORM))))
	  (FUNCALL AUTOLOAD (CONS (CAR FORM) (GET (CAR FORM) 'AUTOLOAD)))
	  'T) ))


(DEFUN |map-cnvd/|| (FORM SYMBOLP)
       (DO  ((Y FORM (CDR Y)))			;Requires two vars to be setup
	    ((NULL Y) 'T)			; BAD-VARS, and BOUND-VARS
	  (AND (NOT (|Certify-no-var-dependency/|| (CAR Y))) 
	       (OR SYMBOLP (NOT (SYMBOLP (CAR Y))))
	       (RETURN () ))))


(DEFUN |Certify-no-var-dependency/|| (FORM)
  (DECLARE (SPECIAL BAD-VARS BOUND-VARS ALL-LOCALS))   
    ; This functions says "yes" if the evaluation of FORM does not depend upon
    ;   any of the variables in BAD-VARS, and where ALL-LOCALS is a flag with
    ;   non-null meaning that there are no special variables in the BAD-VARS
    ; Requires these three special variables to be bound by the caller:
    ;  	BAD-VARS   (sart at list of variables for which dependency is checked)
    ;   BOUND-VARS (start at () ) 
    ;   ALL-LOCALS (start at 'T)
   (PROG (X)
      A  (AND (ATOM (ERRSET (SETQ FORM (MACROEXPAND FORM)) () ))
	      (RETURN () ))
	 #-LISPM 
	 (AND (|cnvd-checkautoload/|| FORM) (GO A))
	 (COND ((ATOM FORM)				  ;True iff FORM can be
		(RETURN (COND ((NOT (SYMBOLP FORM)))	  ; guaranteed not have
			      ((MEMQ FORM BOUND-VARS))	  ; any free references
			      ((MEMQ FORM BAD-VARS) () )  ; to any variable in
			      ('T))))			  ; BAD-VARS
	       ((EQ (CAR FORM) 'QUOTE) (RETURN 'T)))
	 (AND (COND ((NOT (ATOM (CAR FORM)))
		     (COND ((EQ (CAAR FORM) 'LAMBDA)
			    ((LAMBDA (BOUND-VARS)
			       (|Certify-no-var-dependency/|| 
				 `(PROGN ,. (cddar form))))
			     (COND ((ATOM (CADAR FORM)) 
				    (CONS (CADAR FORM) BOUND-VARS))
				   ((APPEND (CADAR FORM) BOUND-VARS))) ))
			   ((SETQ X (MACROEXPAND-1* (CAR FORM)))
 			    (SETQ FORM (CONS (CAR X) (CDR FORM)))
			    (GO A))))
		    ((MEMQ (CAR FORM) '(FUNCTION *FUNCTION))
		     (COND ((ATOM (CADR FORM)) (RETURN 'T))
			   ('T (SETQ FORM (CADR FORM)) (GO A))))
		    ((SYMBOLP (CAR FORM))
		     (COND ((EQ (GET (CAR FORM) '|side-effectsp/||) 
				'|mmcdrside/||))
		      #+FM ((NOT (SYSP (CAR FORM)))
			    () )
			   ((|APPLICABLEP-cnvd/|| (CAR FORM))
			      (COND ((MEMQ (CAR FORM) '(FUNCALL APPLY MAPC MAP 
							MAPCON MAPLIST MAPCAR 
							MAPCAN MAPATOMS *APPLY 
							MAPF MAPVECTOR 
							))
				     (AND (NOT (ATOM (CADR FORM)))
					  (SYMBOLP (CADADR FORM))
					  (|Certify-no-var-dependency/|| 
					    `(,(cadadr form)  () ))))
				    ((MEMQ (CAR FORM) '(EVAL *EVAL READ *READ))
				     () )
				    ('T)))
			   ((MEMQ (CAR FORM) '(OR AND ERRSET CATCH *CATCH
						CATCHALL CATCH-BARRIER
						UNWIND-PROTECT )))
			   ((MEMQ (CAR FORM) '(PROG1 PROG2 PROGN PROGV)))
			   ((OR (MEMQ (CAR FORM) '(STATUS SSTATUS SIGNP))
				(AND (EQ (CAR FORM) 'DO) 
				     (SYMBOLP (CADR FORM))))
			    (SETQ FORM (CDR FORM)) 
			    'T) )))
	      (RETURN (|map-cnvd/|| (CDR FORM) 'T)))
	 (RETURN 
	  (COND ((NOT (SYMBOLP (CAR FORM))) () )
		((MEMQ (CAR FORM) '(SETQ PSETQ))
		 (DO ((Y (CDDR FORM) (CDDR Y)))
		     ((NULL Y) 'T)
		   (AND (NOT (|Certify-no-var-dependency/|| (CAR Y))) 
			(RETURN () ))))
		((EQ (CAR FORM) 'COND) 
		 (DO ((Y (CDR FORM) (CDR Y)))
		     ((NULL Y) 'T)
		   (AND (NOT (|map-cnvd/|| (CAR Y) 'T)) (RETURN () ))))
		((EQ (CAR FORM) 'PROG)
		 ((LAMBDA (BOUND-VARS) (|map-cnvd/|| (CDDR FORM) () ))
		   (APPEND (CADR FORM) BOUND-VARS)))
		((AND (EQ (CAR FORM) 'DO) 
		      (OR (NULL (CADR FORM)) (NOT (ATOM (CADR FORM)))))
		 (SETQ X (MAPCAR '(LAMBDA (X)
				     (COND ((ATOM X) (LIST X () () ))
					   ((LIST (CAR X) (CADR X) (CADDR X)))))
				 (CADR FORM)))
		 (AND (|map-cnvd/|| (MAPCAR 'CADR X) 'T)
		      ((LAMBDA (BOUND-VARS) 
			 (AND (|map-cnvd/|| (MAPCAR 'CADDR X) 'T)
			      (|map-cnvd/|| (CDDDR FORM) () )))
		       (NCONC (MAPCAR 'CAR X) BOUND-VARS))))
		((MEMQ (CAR FORM) '(CASEQ TYPECASEQ))
		 (COND ((NOT (|Certify-no-var-dependency/|| (CADR FORM))) () )
		       ((DO ((Y (CDDR FORM) (CDR Y)))
			    ((NULL Y) 'T)
			  (AND (NOT (|map-cnvd/|| (CDAR Y) 'T)) 
			       (RETURN () ))))))
		(ALL-LOCALS (|map-cnvd/|| (CDR FORM) 'T))   
		 ;;;If all the BAD-VARS are local, then this line will permit 
		 ;;; the use of random functions in FORM, since there can be no 
		 ;;; non-lexical variable dependencies. 
	       ))))



;;;; DEFMACRO

(DEFUN |defmacro-1/|| (X DDC)
   (DECLARE (SPECIAL MACROS))
   (LET (((NAME-ARG DEF-ARGLIST . BODY) X)
	 (MIN 0) (MAX  262143.)  *RSET  #+FM NOUUO 
	  ;; Foo! the following kludgerous crap is here becauses CWH
	  ;;  is too cowardly to introduce the variable DEFMACRO-FOR-COMPILING
	  ;;  into the multics lisp compiler;  foo on CWH -- 3/15/81
	 (DFC (COND ((BOUNDP 'DEFMACRO-FOR-COMPILING)
		      DEFMACRO-FOR-COMPILING)
		    ((STATUS FEATURE COMPLR)
		      MACROS)
		    ('T)))
	 (DCA DEFMACRO-CHECK-ARGS)
	 DECLARE?  USERCOMMENT?  ARGLIST-COMMENT?  
	 RESTARGP  WHOLEP  DEFAULTOPTSP  
	 NAME  ARGLIST  MACROARG  OPT-ARGLIST  OPT-INISL  RESTARG  
	 AUXVARS  AUX-INISL  ALLFLATS  ARGSCHECK  SEQUENCER  TEM  BADP )
     (MULTIPLE-VALUE (BODY DECLARE? USERCOMMENT?) 
		     (|def-decl-comment?/|| BODY X))
     (COND ((SYMBOLP NAME-ARG) (SETQ NAME NAME-ARG))
	   ('T (SETQ NAME (CAR NAME-ARG))
	       (OR (SYMBOLP NAME) (SETQ BADP 'T NAME 'FOO))
	       (AND (SETQ TEM (GETL NAME-ARG '(DEFMACRO-CHECK-ARGS)))
		    (SETQ DCA (EVAL (CADR TEM))))
	       (AND (SETQ TEM (GETL NAME-ARG '(DEFMACRO-DISPLACE-CALL)))
		    (SETQ DDC (EVAL (CADR TEM))))
	       (SETQ TEM (GETL NAME-ARG '(DEFMACRO-FOR-COMPILING)))
	       (SETQ NAME-ARG 
		     #-LISPM 
		     (COND ((NULL TEM) NAME)
			   ('T (SETQ DFC (AND (EVAL (CADR TEM)) 'T))
			       `(,name DEFMACRO-FOR-COMPILING ,dfc )))
		     #+LISPM 
		     (PROG2 (EVAL (CADR TEM)) NAME)) ))
     (SETQ MACROARG (IMPLODE (NCONC (EXPLODEN NAME) '(/- M A C R O A R G))))
     (SETQ ARGLIST 
	   (COND  ;Next two clauses permit forms like "(DEFMACRO FOO X ...)" 
		  ;   and  "(DEFMACRO FOO (<various-args> . X) ...)"
		 ((ATOM DEF-ARGLIST) `(&REST ,def-arglist))
		 ((CDR (SETQ TEM (LAST DEF-ARGLIST)))
		   `(,.(but-tail def-arglist tem) ,(car tem) &REST
		       ,(cdr tem)))
		 ('T DEF-ARGLIST)))
	 ;Process a "&WHOLE" argument, if present
     (COND ((SETQ TEM (MEMQ '&WHOLE ARGLIST))
	     (COND ((OR (ATOM (CDR TEM))
			(MEMQ (CADR TEM) '(&AUX &OPTIONAL &REST &BODY &WHOLE)))
		     (SETQ BADP 'T))
		   ('T (SETQ ARGLIST (NCONC (BUT-TAIL ARGLIST TEM) 
					    (CDDR TEM)))
		       (AND (NULL ARGLIST) (SETQ DCA () ))
		       (COND ((NULL (CADR TEM)) () )
			     ((NOT (SYMBOLP (CADR TEM))) 
			       (COND ((PAIRP (CADR TEM)) 
				       (SETQ ALLFLATS (FLATTEN-SYMS (CADR TEM) 
								    ALLFLATS)
					     AUX-INISL `((DESETQ ,(cadr tem) 
								 ,macroarg))))
				     ('T (SETQ BADP 'T))))
			     ('T (SETQ MACROARG (CADR TEM))))))
	     (OR BADP (SETQ WHOLEP 'T))))
      ;Process "&AUX" arguments, if present
     (COND ((SETQ TEM (MEMQ '&AUX ARGLIST))
	     (SETQ ARGLIST (BUT-TAIL ARGLIST TEM)) 
	     (MAPC '(LAMBDA (X) 
		       (SETQ ALLFLATS 
			     (COND ((ATOM X) (CONS X ALLFLATS))
				   ('T (PUSH `(DESETQ ,(car x) ,(cadr x))
					     AUX-INISL)
				       (FLATTEN-SYMS (CAR X) ALLFLATS)))))
		     (SETQ AUXVARS (CDR TEM)))
	     (SETQ AUX-INISL (NREVERSE AUX-INISL))))
      ;Process any &OPTIONAL and &REST arguments
     (COND ((SETQ TEM (COND ((MEMQ '&OPTIONAL ARGLIST))
			    ((SETQ RESTARGP (OR (MEMQ '&REST ARGLIST)
						(MEMQ '&BODY ARGLIST))))))
	     (SETQ ARGLIST (BUT-TAIL ARGLIST TEM)
		   MIN (LENGTH ARGLIST))
	     (COND (RESTARGP 
		     (SETQ RESTARG (CADR RESTARGP))
		     (AND (OR (AND RESTARG (NOT (SYMBOLP RESTARG)))
			      (CDDR RESTARGP))
			  (SETQ BADP 'T)))
		   ('T 			  ;so (EQ (CAR TEM) '&OPTIONAL)
		      (SETQ OPT-ARGLIST (CDR TEM))
		      (COND ((MEMQ '&OPTIONAL OPT-ARGLIST) (SETQ BADP 'T))
			    ((SETQ RESTARGP (OR (MEMQ '&REST OPT-ARGLIST)
						(MEMQ '&BODY OPT-ARGLIST)))
			     (SETQ OPT-ARGLIST (BUT-TAIL OPT-ARGLIST 
							 RESTARGP))
			     (SETQ RESTARG (CADR RESTARGP))
			     (AND (OR (AND RESTARG (NOT (SYMBOLP RESTARG)))
				      (CDDR RESTARGP))
				  (SETQ BADP 'T)))
			    ('T (SETQ MAX (+ MIN (LENGTH OPT-ARGLIST)))))
		      (SETQ OPT-ARGLIST 
			    (MAPCAR 
			     '(LAMBDA (X)
			       (COND ((OR (NULL X) (SYMBOLP X))
				      (PUSH () OPT-INISL) 
				      X)
				     ('T (SETQ DEFAULTOPTSP 'T)
					 (AND 
					  (COND ((AND (CDR X) (ATOM (CDR X))))
						((NULL (CDDR X)) () )
						((OR (ATOM (CDDR X))
						     (NOT (SYMBOLP (CADDR X)))))
						('T  ; Find the "suppliedp" var
						    (PUSH (CADDR X) ALLFLATS)
						    (CDDDR X)))
					      (SETQ BADP 'T))
					  ;((A . B)  (MUMBLEIFY)) so find A & B
					 (SETQ ALLFLATS (FLATTEN-SYMS 
							  (CAR X) 
							  ALLFLATS))
					 (PUSH X OPT-INISL)
					 () )))
			     OPT-ARGLIST))) )
	     (SETQ ARGLIST (APPEND ARGLIST OPT-ARGLIST RESTARG)))
	   ('T (SETQ MIN (SETQ MAX (LENGTH ARGLIST)))))
     (MAP '(LAMBDA (X) (AND (CAR X) (MEMQ (CAR X) (CDR X)) (SETQ BADP 'T)))
	  (FLATTEN-SYMS ARGLIST ALLFLATS))
     (IF BADP (ERROR '|Bad arg pattern in use of DEFMACRO| `(DEFMACRO ,x)))
     (COND ((NOT DCA))
	   ((AND (= MIN 0) (= MAX 262143.)))
	   ((= MIN MAX) (SETQ ARGSCHECK `(= (LENGTH ,macroarg) ,(1+ min))))
	   ('T (AND (NOT (= MIN 0)) 
		    (SETQ ARGSCHECK `(NOT (< (LENGTH ,macroarg) ,(1+ min)))))
	       (COND ((= MAX 262143.))
		     ('T (SETQ TEM `(NOT (> (LENGTH ,macroarg) ,(1+ max))))
			 (SETQ ARGSCHECK (COND ((NULL ARGSCHECK) TEM)
					       (`(AND ,argscheck ,tem))))))))
     (IF ARGSCHECK (SETQ ARGSCHECK `((AND (NOT ,argscheck) 
					  (ERROR '|Wrong number args for macro| 
						 ,macroarg)))))
     (COND ((NOT (AND OPT-ARGLIST DEFAULTOPTSP)) (SETQ OPT-INISL () ))
	   ((SETQ SEQUENCER (GENTEMP "MacArgL") 
		  OPT-INISL ;currently in reverse order
		  (MAPCAN 
		     #'(LAMBDA (X)
			`((SETQ ,sequencer (CDR ,sequencer))
			  ,.(and x `((DESETQ ,(car x)
					      (COND (,sequencer 
						     ,.(and (cddr x) 
							    `((SETQ ,(caddr x) 'T)))
						     (CAR ,sequencer))
						    (,(cadr x))))))))
		      (DO ((L OPT-INISL (CDR L))) ((OR (NULL L) (CAR L)) L))))
	    (SETQ OPT-INISL (NREVERSE (CDR OPT-INISL)))
	    (PUSH `(SETQ ,sequencer ,(cond ((= min 0) `(CDR ,macroarg))
					   (`(NTHCDR (1+ ,min) ,macroarg))))
		  OPT-INISL) 
	    (PUSH SEQUENCER ALLFLATS))) 
     (COND ((AND (ATOM ARGLIST)			;(), or RESTARG
		 (OR (NULL ARGLIST) (NULL ARGSCHECK))
		 (NULL ALLFLATS)
		 (NULL AUX-INISL) 
		 (NULL OPT-INISL) )
	     (PUSH (COND ((NULL ARGLIST)
			  (COND ((OR (NULL DCA) RESTARGP) MACROARG) 
				(`(AND (CDR ,macroarg) 
				       (ERROR '|No args allowed for this macro|
					      ,macroarg)))) )
			 ('T (AND (NOT (EQ ARGLIST RESTARG)) 
				  (+INTERNAL-LOSSAGE '&REST 
						     'DEFMACRO 
						     (LIST ARGLIST RESTARG)))
			     (SETQ MACROARG ARGLIST)
			      ;; A simple case - "(DEFMACRO FOO X (doit X))"
			     `(SETQ ,macroarg (CDR ,macroarg))))
		   BODY))
	   ('T (SETQ ARGLIST-COMMENT? 
		          `((COMMENT ARGLIST = ,(or (nreverse (cdr (memq '&AUX (reverse def-arglist))))
						    def-arglist)))
		     BODY `(,.argscheck 
			      (LET ((,arglist (CDR ,macroarg))  ,.allflats)
				   ,.opt-inisl
				   ,.aux-inisl 
				   ,. body)))))
     (IF DDC (SETQ BODY (COND ((EQ DDC 'DEFMACRO-DISPLACE) 
			        `((DISPLACE ,macroarg (PROGN ,. body))))
			      (`((OR (MACROFETCH ,macroarg)
				     (MACROMEMO ,macroarg 
						(PROGN ,. body) 
						',name)))))))
     (SETQ BODY `(MACRO ,name-arg (,macroarg) 
			,.declare?
			,.usercomment? 
			,.arglist-comment? 
			,. body))
     (setq ddc `(FLUSH-MACROMEMOS 
		  ',name 
		  ,(cond ((eq ddc MACROEXPANDED) 
			   'MACROEXPANDED)
			 ((or (null ddc) (eq ddc 'DEFMACRO-DISPLACE))
			   () )
			 ((or (eq ddc 'FLUSH-MACROMEMOS)
			      (not (memq ddc defmax-counter-variables)))
			   `'FLUSH-MACROMEMOS)
			 ( `',ddc))))
     (if (and ddc (not dfc)) 
	 (setq ddc `(EVAL-WHEN (EVAL COMPILE) ,ddc)))
     `(PROGN 'COMPILE ,ddc ,body)))

;;;; DEFMACRO and MACRO

#-Lispm (declare (own-symbol DEFMACRO DEFMACRO-DISPLACE))

(defun (DEFMACRO MACRO) (x)  
   (|defmacro-1/|| 
	(cdr x) 
	(if (boundp 'DEFMACRO-DISPLACE-CALL) DEFMACRO-DISPLACE-CALL)))

(defun (DEFMACRO-DISPLACE MACRO) (x) 
   (|defmacro-1/|| (CDR X) 'DEFMACRO-DISPLACE))


;;; Just for starters, consider the case of  ((FIND it) 1), where
;;; FIND is a macro s.t. (FIND it) ==> FOO,

;;; NIL version of MACRO is in the "NILMAC" file.


#+FM 
(defun (MACRO MACRO) (x)
   (declare (special MACROS))
   (let ((name (cadr x)) 
	 (bvl-body (cddr x))
	 (dfc (cond ((boundp 'DEFMACRO-FOR-COMPILING)
		      DEFMACRO-FOR-COMPILING)
		    ((status FEATURE COMPLR)
		      MACROS)
		    ('T)))
	 tem)
      (cond ((not (atom name))
	     (setq tem (getl name '(DEFMACRO-FOR-COMPILING))
		   name (car name))
	     (and tem (setq dfc (eval (cadr tem))))))
      `(DEFUN ,@(cond (dfc `((,name MACRO)))
		      ('t  `(,name MACRO))) 
	      ,. bvl-body)))

ββββ